home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
CD ROM Paradise Collection 4
/
CD ROM Paradise Collection 4 1995 Nov.iso
/
program
/
tjgold.zip
/
INSTALL.001
/
GOLDHARD.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1995-07-12
|
31KB
|
1,186 lines
{--------------------------------------------------------------------------}
{ Product: TechnoJock's Turbo Toolkit }
{ Version: GOLD }
{ Build: 1.01 }
{ }
{ Copyright 1986-1995 TechnoJock Software, Inc. }
{ All Rights Reserved }
{ Restricted by License }
{--------------------------------------------------------------------------}
{**********************************}
{** Unit: GOLDHARD **}
{**********************************}
{++++++++++++++++++++++++++++++} unit GOLDHARD; {++++++++++++++++++++++++++++}
{$I GOLDFLAG.INC}
{$IFNDEF GOLDHARD}
{$DEFINE GOLDHARD}
{$ENDIF}
{++++++++++++++++++++++++++++++++} INTERFACE {+++++++++++++++++++++++++++++++}
uses DOS, CRT, GoldStr, GoldAttr;
const
FingerPrint: string[8] = 'EMMXXXX0';
Ignore:byte = 255; {background attribute}
type
ErrMsgFunc = function (Ecode:integer):string;
gVideo = (UnKnown, Mono, CGA, MCGAMono, MCGACol, EGAMono, EGACol, VGAMono, VGACol);
OSDate = (USA,Europe,Japan);
LabelStatus = ( CorrectLabel, NoLabel, IncorrectLabel );
Str12 = string[12];
tExFCB = record
FF: byte; { Signals DOS that this is an ExFCB, must be $FF }
Reserved0: array[1..5] OF byte; { Reserved By DOS, must be Zero's }
Attribute: byte; { Same meaning as directory entry }
DriveID: byte; { 0=default, 1=A, 2=B, etc }
Filename: array[1..8] OF char; { Left justified, padded with blanks }
Extension: array[1..3] OF char; { Left justified, padded with blanks }
CurBlock: word; { The current block number }
RecSize: word; { Default of 128 bytes }
FileSize: longint;
Date: word; { Date created/updated }
Time: word; { Time created/updated }
Reserved: array[1..8] OF byte;
CurRec: byte; { The current record number }
Relative: longint; { Random record number }
end;
pMediaInfo = ^MediaInfo;
MediaInfo = record
InfoLevel: word;
SerialNumber: longint;
VolLabel: Array [ 1..11 ] of byte;
FatType: Array [ 1..8 ] of byte;
end;
HWDataRecPtr = ^HardwareRec;
HardwareRec = record
{hardware data}
DiskInfo: SearchRec;
ThePathStr: PathStr;
MediaRec: MediaInfo;
MediaPointer: pMediaInfo;
pTheCurrentPath: pointer;
vExFCB: tExFCB;
end; { HardwareRec }
DOSDataRecPtr = ^DOSDataRec;
DOSDataRec = record
{DOS Data}
IDPtr: pointer;
ROMPtr: pointer;
vMainInfo: word;
vComputerID: byte;
vRomDate: string[8];
end; { DOSDataRec }
MemDataRecPtr = ^MemDataRec;
MemDataRec = record
{memory data}
Regs: registers;
ID: string[8];
vMemInfo: word;
vXMSInstalled,
vEMMInstalled: boolean;
vEMMMajor: byte;
vEMMMinor: byte;
end; { MemDataRec }
OSDataRecPtr = ^OSDataRec;
OSDataRec = record
{OS Data}
CountryBuf: array[0..$21] of byte;
Country:word;
vMajor: byte;
vMinor: byte;
vCountry: word;
vDateFmt: OSDate;
vCurrency: string[5];
vThousands: byte;
vDecimal: byte;
vDateSeparator: byte;
vTimeSeparator: byte;
vTimeFmt: byte;
vCurrencyFmt: byte;
vCurrencyDecPlaces: byte;
end; { OSDataRec }
HardSet = record
ECode: integer;
{screen data}
Width: byte; {how wide is screen}
Depth: byte; {how many lines}
ScreenPtr: pointer; {memory location of screen data}
DisplayType: gVideo; {video display type}
ColorSystem: boolean; {does video support color}
ForceBW: boolean; {use BW color schemes}
{Misc}
Regs: registers;
AnimateDelay: integer;
EMsgFunc: ErrMsgFunc;
end;
var
HardVars: HardSet;
function LastHardError: integer;
function GetDispMode: byte;
function OSVersion(Major:boolean): byte;
function OSVersionStr: string;
function ColorScreen: boolean;
function ComputerID: byte;
function ParallelPorts: byte;
function SerialPorts: byte;
function FloppyDrives: byte;
function ROMDate: string;
function GameAdapter: boolean;
function SerialPrinter: boolean;
function MathChip: boolean;
function BaseMemory: integer;
function EMMInstalled: boolean;
function XMSInstalled: boolean;
function EMMVersionMajor: byte;
function EMMVersionMinor: byte;
function EMMVersion: string;
function OSVersionMajor: byte;
function OSVersionMinor: byte;
function Country: word;
function Currency: string;
function DateFmt: OSDate;
function ThousandsSep: char;
function DecimalSep: char;
function DateSep: char;
function TimeSep: char;
function TimeFmt: byte;
function CurrencyFmt: byte;
function CurrencyDecPlaces: byte;
{hardware info}
procedure ShowRegs; { for trouble shooting only }
function LastDrv: integer;
function LogicalDriveNum( Drive: char ): byte;
function PhysicalDriveNum( Drive: char ): byte;
function DriveChar( Drive: byte ): char;
function GetMediaSerialNumber( Drive: byte ): string;
function SetMediaSerialNumber( Drive: byte;Serial: longint ): boolean;
function MediaIsLabeled( Drive: byte ): boolean;
function DeleteVolumeLabel( Drive: byte ): byte;
function SetVolumeLabel( Drive: byte; LabelStr: Str12 ): byte;
function GetVolumeLabel( Drive: byte ): string;
function LabelIsCorrect( Drive: byte; LabelName: string ): LabelStatus;
function IsPhantom: boolean;
function DriveExists(Drive: char): boolean;
function DriveIsReady( Drive: byte ): boolean;
procedure SetDriveTo( Drive: byte );
function CurrentDriveByte: byte;
function CurrentDriveChar: char;
procedure SetCurrentDriveTo( NewDrive: char );
function CurrentPathStr: DirStr;
function SetCurrentPath( NewPath: PathStr ): boolean;
function ValidPath( Path: PathStr ): boolean;
{+++++++++++++++++++++++++++++} IMPLEMENTATION {+++++++++++++++++++++++++++++}
function LastHardError: integer;
{}
begin
LastHardError := HardVars.ECode;
end; { LastHardError }
procedure GetOSData(var OSData:OSDataRec);
{}
var P: byte;
begin
with HardVars do
begin
with regs do
begin
with OSData do
begin
Ah := $30;
msdos(Regs);
vMajor := Al;
vMinor := Ah;
AX := $3800;
DS := seg(CountryBuf);
DX := ofs(CountryBuf);
intr($21,Regs);
vCountry := Regs.BX;
if vMajor >= 3 then
begin
vDateFmt := OSDate(vCountry);
vCurrency := ' ';
move(CountryBuf[$2],vCurrency[1],5);
P := pos(#0,vCurrency); {ASCIIZ string form}
if P > 0 then
delete(vCurrency,P,5);
vThousands := CountryBuf[$7];
vDecimal := CountryBuf[$9];
vDateSeparator := CountryBuf[$B];
vTimeSeparator := CountryBuf[$D];
vTimeFmt := CountryBuf[$11];
vCurrencyFmt := CountryBuf[$F];
vCurrencyDecPlaces := CountryBuf[$10];
end else
begin
vDateFmt := OSDate(vCountry);
vCurrency := chr(CountryBuf[$2]);
vThousands := CountryBuf[$04];
vDecimal := CountryBuf[$06];
vDateSeparator := ord('/'); {not avialable before DOS 3}
vTimeSeparator := ord(':');
vTimeFmt := 1;
vCurrencyFmt := 0;
vCurrencyDecPlaces := 2;
end;
end;
end;
end;
end; { GetOSData }
procedure GetDOSData(var DosData:DosDataRec);
{}
begin
with HardVars do
begin
with DOSData do
begin
{$IFDEF DPMI}
vComputerID := 0;
vRomdate := 'Unknown';
{$ELSE}
IDPtr := ptr($F000,$FFFE);
vComputerID := byte(IDPtr^);
ROMPtr := ptr($F000,$FFF5);
move(ROMPtr^,vROMDate[1],8);
vROMDate[0] := chr(8);
intr($11,Regs);
vMainInfo := Regs.AX;
{$ENDIF}
end;
end;
end; { GetDOSData }
procedure GetMemData(var MemData:MemDataRec);
{}
begin
{memory}
with HardVars do
begin
with MemData do
begin
regs.AX := $4300;
intr($2F,regs);
vXMSInstalled := (regs.al = $80); {himem.sys}
{$IFDEF DPMI}
vEMMInstalled := false;
{$ELSE}
intr($12,Regs);
vMemInfo := Regs.AX;
with regs do
begin
Ah := $35;
Al := $67;
Intr($21,Regs); {ES now points to int $67 segment -- id is 10 bytes on}
move(mem[ES:$000A],ID[1],8);
ID[0] := chr(8);
vEMMInstalled := (MemData.ID = FingerPrint);
end;
{$ENDIF}
vEMMMajor := 0;
vEMMMinor := 0;
if vEMMInstalled then
begin
{get driver version number}
Regs.Ah := $46;
intr($67,Regs);
if Regs.Ah = 0 then
begin
vEMMMajor := Regs.Al shr 4;
vEMMMinor := Regs.AL and $F;
end;
end;
end;
end;
end; { GetMemData }
procedure GetHWData(var HWData:HardWareRec);
{}
begin
with HardVars do
begin
with HWData.MediaRec Do
begin
InfoLevel := 0;
Fillchar(SerialNumber,SizeOf(SerialNumber),#0);
Fillchar(VolLabel,SizeOf(VolLabel),#0);
Fillchar(FatType,SizeOf(FatType),#0);
end;
HWData.MediaPointer := @HWData.MediaRec;
with HWData.vExFCB Do
begin
FF := $FF;
Fillchar(Reserved0,SizeOf(Reserved0),0);
Attribute := VolumeID;
DriveID := 1; { Default of 'A' }
Fillchar(Filename,SizeOf(Filename),' ');
Fillchar(Extension,SizeOf(Extension),' ');
CurBlock := 0;
RecSize := 0;
FileSize := 0;
Date := 0;
Time := 0;
Fillchar(Reserved,SizeOf(Reserved),0);
CurRec := 0;
Relative := 0;
end
end;
end; { GetHWData }
function TestVideo: gVideo;
{}
var
Regs: Registers;
Equip: byte;
Temp: gVideo;
begin
with Regs do
begin
Al := $00;
Ah := $1A; {get VGA info}
Intr($10,Regs);
if Al = $1A then
case Bl of
$00: Temp := unknown;
$01: Temp := Mono;
$04: Temp := EGACol;
$05: Temp := EGAMono;
$07: Temp := VGAMono;
$08: Temp := VGACol;
$0A,
$0C: Temp := MCGACol;
$0B: Temp := MCGAMono;
else
Temp := CGA;
end {case}
else {more checking needed}
begin
Ah := $12;
BX := $10; {get EGA data}
Intr($10,Regs);
if BX = $10 then {EGA or Mono}
begin
Intr($11,Regs);
if ((Al and $30) shr 4) = 3 then
Temp := Mono
else
Temp := CGA;
end else
begin
Ah := $12;
BX := $10; {one more time!}
Intr($10,Regs);
if Bh = 0 then
Temp := EGACol
else
Temp := EGAMono;
end; {if}
end; {if}
end; {with}
TestVideo := Temp;
end; { TestVideo }
function GetDispMode:byte;
{}
var Regs: registers;
begin
with Regs do
begin
Ax := $0F00;
Intr($10,Regs); {get video display mode}
GetDispMode := Al;
end;
end; { GetDispMode }
function OSVersion(Major:boolean):byte;
{if Major is false the minor version number is returned, e.g. 2 for DOS 3.2}
var Regs:registers;
begin
with Regs do
begin
Ah := $30;
msdos(Regs);
if Major then
OSVersion := Al
else
OSVersion := Ah;
end;
end; { OSVersion }
function OSVersionStr: string;
{}
var OSData: OSDataRec;
begin
with HardVars do
begin
GetOSData(OSData);
with OSData do
OSVersionStr := IntToStr(vMajor)+'.'+IntToStr(vMinor);
end;
end; { OSVersionStr }
function ColorScreen:boolean;
{}
begin
with HardVars do
ColorScreen := ColorSystem and (HardVars.ForceBW = false);
end; { ColorScreen }
function ComputerID: byte;
{}
var DosData: DosDataRec;
begin
with HardVars do
begin
GetDosData(DosData);
ComputerID := DosData.vComputerID;
end;
end; { ComputerID }
function ParallelPorts: byte;
{}
var DosData: DosDataRec;
begin
with HardVars do
begin
GetDOSData(DosData);
ParallelPorts := hi(DosData.vMainInfo) shr 6;
end;
end; { ParallelPorts }
function SerialPorts: byte;
{}
var DosData: DosDataRec;
begin
with HardVars do
begin
GetDOSData(DosData);
SerialPorts := hi(DosData.vMainInfo) and $0F shr 1;
end;
end; { SerialPorts }
function FloppyDrives: byte;
{}
var DOSData: DosDataRec;
begin
with HardVars do
begin
GetDOSData(DosData);
FloppyDrives := ((DosData.vMainInfo and $C0) shr 6) + 1;
end;
end; { FloppyDrives }
function ROMDate: string;
{}
var DosData: DosDataRec;
begin
with HardVars do
begin
GetDOSData(DosData);
ROMDate := DosData.vROMDate;
end;
end; { ROMDate }
function GameAdapter: boolean;
{}
var DosData: DosDataRec;
begin
with HardVars do
begin
GetDOSData(DosData);
GameAdapter := ((DosData.vMainInfo and $1000) = 1);
end;
end; { GameAdapter }
function SerialPrinter: boolean;
{}
var DosData: DosDataRec;
begin
with HardVars do
begin
GetDOSData(DosData);
SerialPrinter := ((DosData.vMainInfo and $2000) = 1);
end;
end; { SerialPrinter }
function MathChip: boolean;
{}
var DosData: DosDataRec;
begin
with HardVars do
begin
GetDOSData(DosData);
MathChip := ((DosData.vMainInfo and $2) = $2);
end;
end; { MathChip }
{*************************}
{** M E M S T U F F **}
{*************************}
function BaseMemory: integer;
{}
var MemData: MemDataRec;
begin
with HardVars do
begin
GetMemData(MemData);
BaseMemory := MemData.vMemInfo;
end;
end; { BaseMemory }
function EMMInstalled: boolean;
{Expanded memory}
var MemData: MemDataRec;
begin
with HardVars do
begin
GetMemData(MemData);
EMMInstalled := MemData.vEMMInstalled;
end;
end; { EMMInstalled }
function XMSInstalled: boolean;
{Extended memory}
var MemData: MemDataRec;
begin
with HardVars do
begin
GetMemData(MemData);
XMSInstalled := MemData.vXMSInstalled;
end;
end; { XMSInstalled }
function EMMVersionMajor: byte;
{}
var MemData: MemDataRec;
begin
with HardVars do
begin
GetMemData(MemData);
EMMVersionMajor := MemData.vEMMMajor;
end;
end; { EMMVersionMajor }
function EMMVersionMinor: byte;
{}
var MemData: MemDataRec;
begin
with HardVars do
begin
GetMemData(MemData);
EMMVersionMinor := MemData.vEMMMinor;
end;
end; { EMMVersionMinor }
function EMMVersion: string;
{}
begin
EMMVersion := chr(EMMVersionMajor + 48)+'.'+chr(EMMVersionMinor + 48);
end; { EMMVersion }
{*************************}
{** O. S. S T U F F **}
{*************************}
function OSVersionMajor: byte;
{}
var OSData: OSDataRec;
begin
with HardVars do
begin
GetOSData(OSData);
OSVersionMajor := OSData.vMajor;
end;
end; { OSVersionMajor }
function OSVersionMinor: byte;
{}
var OSData: OSDataRec;
begin
with HardVars do
begin
GetOSData(OSData);
OSVersionMinor := OSData.vMinor;
end;
end; { OSVersionMinor }
function Country: word;
{}
var OSData: OSDataRec;
begin
with HardVars do
begin
GetOSData(OSData);
Country := OSData.vCountry;
end;
end; { Country }
function Currency: string;
{}
var OSData: OSDataRec;
begin
with HardVars do
begin
GetOSData(OSData);
Currency := OSData.vCurrency;
end;
end; { Currency }
function DateFmt: OSDate;
{}
var OSData: OSDataRec;
begin
with HardVars do
begin
GetOSData(OSData);
DateFmt := OSData.vDateFmt;
end;
end; { DateFmt }
function ThousandsSep: char;
{}
var OSData: OSDataRec;
begin
with HardVars do
begin
GetOSData(OSData);
ThousandsSep := chr(OSData.vThousands);
end;
end; { ThousandsSep }
function DecimalSep: char;
{}
var OSData: OSDataRec;
begin
with HardVars do
begin
GetOSData(OSData);
DecimalSep := chr(OSData.vDecimal);
end;
end; { DecimalSep }
function DateSep: char;
{}
var OSData: OSDataRec;
begin
with HardVars do
begin
GetOSData(OSData);
DateSep := chr(OSData.vDateSeparator);
end;
end; { DateSep }
function TimeSep: char;
{}
var OSData: OSDataRec;
begin
with HardVars do
begin
GetOSData(OSData);
TimeSep := chr(OSData.vTimeSeparator);
end;
end; { TimeSep }
function TimeFmt: byte;
{}
var OSData: OSDataRec;
begin
with HardVars do
begin
GetOSData(OSData);
TimeFmt := OSData.vTimeFmt;
end;
end; { TimeFmt }
function CurrencyFmt: byte;
{}
var OSData: OSDataRec;
begin
with HardVars do
begin
GetOSData(OSData);
CurrencyFmt := OSData.vCurrencyFmt;
end;
end; { CurrencyFmt }
function CurrencyDecPlaces: byte;
{}
var OSData: OSDataRec;
begin
with HardVars do
begin
GetOSData(OSData);
CurrencyDecPlaces := OSData.vCurrencyDecPlaces;
end;
end; { CurrencyDecPlaces }
{***********************************}
{** H A R D W A R E S T U F F **}
{***********************************}
procedure ShowRegs;
{ DEVELOPERS NOTE - for trouble shooting only }
var CurX, CurY: byte;
begin
with HardVars do
begin
CurX := WhereX;
CurY := WhereY;
with Regs Do
begin
GotoXY(63,1);
Write('┌──────────────┐');
GotoXY(63,2);
Write('│ Registers │');
GotoXY(63,3);
Write('│ │');
GotoXY(63,4);
Write('│ AH - $',IntToHEXStr(AH,2):2,' │');
GotoXY(63,5);
Write('│ AL - $',IntToHEXStr(AL,2):2,' │');
GotoXY(63,6);
Write('│ BH - $',IntToHEXStr(BH,2):2,' │');
GotoXY(63,7);
Write('│ BL - $',IntToHEXStr(BL,2):2,' │');
GotoXY(63,8);
Write('│ CH - $',IntToHEXStr(CH,2):2,' │');
GotoXY(63,9);
Write('│ CL - $',IntToHEXStr(CL,2):2,' │');
GotoXY(63,10);
Write('│ DH - $',IntToHEXStr(DH,2):2,' │');
GotoXY(63,11);
Write('│ DL - $',IntToHEXStr(DL,2):2,' │');
GotoXY(63,12);
Write('│ AX - $',IntToHEXStr(AX,4):4,' │');
GotoXY(63,13);
Write('│ BX - $',IntToHEXStr(BX,4):4,' │');
GotoXY(63,14);
Write('│ CX - $',IntToHEXStr(CX,4):4,' │');
GotoXY(63,15);
Write('│ DX - $',IntToHEXStr(DX,4):4,' │');
GotoXY(63,16);
Write('│ BP - $',IntToHEXStr(BP,4):4,' │');
GotoXY(63,17);
Write('│ SI - $',IntToHEXStr(SI,4):4,' │');
GotoXY(63,18);
Write('│ DI - $',IntToHEXStr(DI,4):4,' │');
GotoXY(63,19);
Write('│ DS - $',IntToHEXStr(DS,4):4,' │');
GotoXY(63,20);
Write('│ ES - $',IntToHEXStr(ES,4):4,' │');
GotoXY(63,21);
Write('│ │');
GotoXY(63,22);
Write('└──────────────┘');
end;
GotoXY(CurX,CurY);
end;
end; { ShowRegs }
function LastDrv: integer;
{}
var Regs: registers;
begin
with Regs do
begin
AH := $0E;
DL := pred(CurrentDriveByte);
MsDos(Regs);
LastDrv := AL;
end;
end; { LastDrv }
function LogicalDriveNum( Drive: char ): byte;
{converts drive letter to logical drive byte}
begin
Drive := upCase(Drive);
if ( Drive in ['A'..'Z'] ) then
LogicalDriveNum := (ord(Drive) - 65)
else
LogicalDriveNum := 0;
end; { LogicalDriveNum }
function PhysicalDriveNum( Drive: char ): byte;
{converts drive letter to physical drive byte}
begin
Drive := upcase(Drive);
if ( Drive in ['A'..'Z'] ) then
PhysicalDriveNum := (ord(Drive) - 64)
else
PhysicalDriveNum := 0;
end; { PhysicalDriveNum }
function DriveChar( Drive: byte ): char;
{converts drive byte to drive char}
begin
if ( Drive in [1..26] ) then
DriveChar := chr(Drive + 64)
else
DriveChar := CurrentDriveChar;
end; { DriveChar }
function GetMediaSerialNumber( Drive: byte ): string;
{}
var Answer: string[4];
X: integer;
HWData: HardWareRec;
begin
with HardVars do
begin
GetHWData(HWData);
with Regs Do
begin
AH := $69;
AL := $00;
BL := Drive;
DS := Seg(HWData.MediaPointer^);
DX := Ofs(HWData.MediaPointer^);
Intr($21,Regs);
if ( Flags AND Fcarry ) = 0 then
begin
Move(HWData.MediaPointer^.SerialNumber,Answer[1],4);
Answer[0] := #4;
GetMediaSerialNumber :=
concat(IntToHexStr(ord(Answer[4]),2),
IntToHexStr(ord(Answer[3]),2),'-',
IntToHexStr(ord(Answer[2]),2),
IntToHexStr(ord(Answer[1]),2));
end else
GetMediaSerialNumber := '';
end;
end;
end; { GetMediaSerialNumber }
function SetMediaSerialNumber( Drive: byte; Serial: longint ): boolean;
{}
var HWData: HardWareRec;
begin
with HardVars do
begin
SetMediaSerialNumber := false;
GetHWData(HWData);
HWData.MediaPointer^.SerialNumber := Serial;
with Regs Do
begin
AH := $69;
AL := $01;
BL := Drive;
DS := Seg(HWData.MediaPointer^);
DX := Ofs(HWData.MediaPointer^);
Intr($21,Regs);
SetMediaSerialNumber := (( Flags AND Fcarry ) = 0)
end;
end;
end; { SetMediaSerialNumber }
function MediaIsLabeled( Drive: byte ): boolean;
{}
var SrchRec: SearchRec;
begin
MediaIsLabeled := false;
FindFirst(DriveChar(Drive) + ':\*.*',VolumeID,SrchRec);
MediaIsLabeled := (DosError = 0);
end; { MediaIsLabeled }
function DeleteVolumeLabel( Drive: byte ): byte;
{}
var HWData: HardWareRec;
begin
with HardVars do
begin
DeleteVolumeLabel := $FF;
if MediaIsLabeled(Drive) then
begin
GetHWData(HWData);
with HWData.vExFCB Do
begin
FF := $FF;
Attribute := VolumeID;
DriveID := Drive; { A = 1, B = 2, ... }
Fillchar(Filename,8,'?');
Fillchar(Extension,3,'?');
end;
with Regs Do
begin
AH := $13; { Delete file FCB }
DS := Seg(HWData.vExFCB);
DX := Ofs(HWData.vExFCB);
Intr($21,Regs);
DeleteVolumeLabel := AL;
end;
end;
end;
end; { DeleteVolumeLabel }
function SetVolumeLabel( Drive: byte; LabelStr: Str12 ): byte;
{}
var I: Integer;
HWData: HardWareRec;
begin
with HardVars do
begin
SetVolumeLabel := $FF;
if MediaIsLabeled(Drive) and (DeleteVolumeLabel(Drive) = 0 ) then
begin
if Pos('.',LabelStr) <> 0 then
Delete(LabelStr,Pos('.',LabelStr),1);
While Length(LabelStr) <> 11 Do
LabelStr := LabelStr + ' ';
GetHWData(HWData);
with HWData.vExFCB Do
begin
FF := $FF;
Attribute := VolumeID;
DriveID := Drive;
Fillchar(Filename,8,#0);
Fillchar(Extension,3,#0);
For I := 1 to 8 Do
Filename[I] := UpCase(LabelStr[I]);
For I := 9 to 11 Do
Extension[ I - 8 ] := UpCase(LabelStr[I]);
end;
with Regs Do
begin
AH := $16; { Create File FCB }
DS := Seg(HWData.vExFCB);
DX := Ofs(HWData.vExFCB);
Intr($21,Regs);
with Regs Do
begin
AH := $10; { Closes an open FCB }
DS := Seg(HWData.vExFCB);
DX := Ofs(HWData.vExFCB);
Intr($21,Regs);
SetVolumeLabel := AL;
end;
end;
end;
end;
end; { SetVolumeLabel }
function GetVolumeLabel( Drive: byte ): string;
{}
var SrchRec: SearchRec;
begin
SrchRec.Name := '';
GetVolumeLabel := '';
FindFirst(DriveChar(Drive) + ':\*.*',VolumeID,SrchRec);
if DosError = 0 then
GetVolumeLabel := Strip('A','.',SrchRec.Name)
end; { GetVolumeLabel }
function LabelIsCorrect( Drive: byte; LabelName: string ): LabelStatus;
{}
var TempLabel: Str12;
begin
if MediaIsLabeled(Drive) AND ( Length(LabelName) > 0 ) then
begin
LabelIsCorrect := IncorrectLabel;
TempLabel := GetVolumeLabel( Drive );
LabelName := Strip('A','.',LabelName);
if ( TempLabel = SetUpper( LabelName )) then
LabelIsCorrect := CorrectLabel;
end else
LabelIsCorrect := NoLabel;
end; { LabelIsCorrect }
function IsPhantom: boolean;
{}
begin
with HardVars do
begin
IsPhantom := false;
Intr($11,Regs);
IsPhantom := (( Regs.AX AND $00C0 ) = 0 );
{ Could probably read: IsPhantom := (FloppyDrives = 1); }
end;
end;
function DriveExists(Drive: Char): boolean;
{}
var
Regs:registers;
StartDrive: byte;
begin
drive := upcase(Drive);
if not (ord(drive) in [65..90]) then
DriveExists := false
else
with Regs do
begin
StartDrive := CurrentDriveByte;
Ah := $0E; {select the drive to be tested}
Dl := ord(drive) - 65;
intr($21,Regs);
Ah := $19; {get the current drive again}
intr($21,Regs);
DriveExists := Al = ord(drive) - 65;
if PhysicalDriveNum(drive) = 2 then
DriveExists := not IsPhantom;
SetCurrentDriveTo(DriveChar(StartDrive));
end;
end; { DriveExists }
function DriveIsReady( Drive: byte ): boolean;
{}
begin
with HardVars do
begin
DriveIsReady := false;
if ( FloppyDrives = 1 ) then
SetDriveTo(Drive);
with Regs Do
begin
AH := $32; { Get DOS drive parameter block }
DL := Drive; { $00=default, $01=A, $02=B ... }
Intr($21,Regs);
DriveIsReady := (AL = 0);
end;
end;
end; { DriveIsReady }
procedure SetDriveTo( Drive: byte );
{ Eliminates "Insert diskette in drive" message }
begin
with HardVars do
begin
if FloppyDrives = 1 then
case Drive of
1: Mem[$0000:$0504] := 00;
2: Mem[$0000:$0504] := 01;
end;
end;
end; { SetDriveTo }
function CurrentDriveByte: byte;
{}
var Regs: registers;
begin
with Regs do
begin
AH := $19; { Get Default Drive }
Intr($21,Regs);
CurrentDriveByte := AL + 1;
end;
end; { CurrentDriveByte }
function CurrentDriveChar: char;
{returns the character of the current drive}
begin
CurrentDriveChar := chr(CurrentDriveByte + 64);
end; { CurrentDriveChar }
procedure SetCurrentDriveTo( NewDrive: char );
{}
begin
with HardVars do
begin
if ( Ord(Upcase(NewDrive)) - 64 ) <= FloppyDrives then
Fillchar(Regs,SizeOf(Regs),#0);
with Regs Do
begin
AH := $0E; { Select Disk }
DL := Ord(NewDrive) - 65;
Intr($21,Regs);
end;
end;
end; { SetCurrentDriveTo }
function CurrentPathStr: DirStr;
{returns the current path string.
this excludes the final backslash}
var TempStr: dirstr;
begin
GetDir(0,TempStr);
CurrentPathStr := TempStr;
end; { CurrentPathStr }
function SetCurrentPath( NewPath: PathStr ): boolean;
{}
begin
if NewPath[length(NewPath)] = '\' then
delete(NewPath,length(NewPath),1);
{$I-} ChDir(NewPath); {$I+}
SetCurrentPath := (IOResult = 0);
end; { SetCurrentPath }
function ValidPath( Path: PathStr ): boolean;
{}
var PathLen,
gResult: Integer;
FN: file;
begin
PathLen := Length( Path );
if ( Path[PathLen] = '\' ) AND
( Path[Pred(PathLen)] <> ':' ) then
Delete(Path,PathLen,1);
assign(FN,Path+'\nul');
{$I-} reset(FN); {$I+}
ValidPath := (IOResult = 0)
end; { ValidPath }
{**********************************************}
{** U N I T I N I T I A L I Z A T I O N **}
{**********************************************}
procedure HardDefaultSettings;
{}
begin
with HardVars do
begin
ForceBW := false;
AnimateDelay := 100;
end;
end; { HardDefaultSettings }
procedure GoldHardInit;
{internal}
var DM:integer;
begin
HardDefaultSettings;
with HardVars do
begin
ECode := 0;
DisplayType := TestVideo;
DM := GetDispMode;
{$IFDEF DPMI}
if DM = 7 then
ScreenPtr := ptr(segB000,0) {Mono}
else
ScreenPtr := ptr(segB800,0); {Color}
{$ELSE}
if DM = 7 then
ScreenPtr := ptr($B000,0) {Mono}
else
ScreenPtr := ptr($B800,0); {Color}
{$ENDIF}
{$IFDEF FORCEMONO} {for debugging colors on dual monitors}
ScreenPtr := ptr(segB000,0); {Color}
{$ENDIF}
ColorSystem := DM <> 7;
Width := 80;
Depth := succ(Hi(WindMax));
end;
end; { GoldHardInit }
begin
GoldHardInit;
end.